home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Technology Demos and Tools.iso / holoview / lib / tcl / init.tcl next >
Encoding:
Text File  |  1994-04-20  |  7.8 KB  |  260 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # $Header: /user6/ouster/tcl/library/RCS/init.tcl,v 1.28 93/10/08 09:11:21 ouster Exp $ SPRITE (Berkeley)
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # All rights reserved.
  10. #
  11. # Permission is hereby granted, without written agreement and without
  12. # license or royalty fees, to use, copy, modify, and distribute this
  13. # software and its documentation for any purpose, provided that the
  14. # above copyright notice and the following two paragraphs appear in
  15. # all copies of this software.
  16. #
  17. # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  18. # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  19. # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  20. # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  21. #
  22. # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  23. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  24. # AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  25. # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  26. # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  27. #
  28.  
  29. set auto_path [info library]
  30.  
  31. # unknown:
  32. # Invoked when a Tcl command is invoked that doesn't exist in the
  33. # interpreter:
  34. #
  35. #    1. See if the autoload facility can locate the command in a
  36. #       Tcl script file.  If so, load it and execute it.
  37. #    2. See if the command exists as an executable UNIX program.
  38. #       If so, "exec" the command.
  39. #    3. If the command was invoked at top-level:
  40. #        (a) see if the command requests csh-like history substitution
  41. #        in one of the common forms !!, !<number>, or ^old^new.  If
  42. #        so, emulate csh's history substitution.
  43. #        (b) see if the command is a unique abbreviation for another
  44. #        command.  If so, invoke the command.
  45.  
  46. proc unknown args {
  47.     global auto_noexec auto_noload env unknown_pending tcl_interactive;
  48.  
  49.     set name [lindex $args 0]
  50.     if ![info exists auto_noload] {
  51.     #
  52.     # Make sure we're not trying to load the same proc twice.
  53.     #
  54.     if [info exists unknown_pending($name)] {
  55.         unset unknown_pending($name)
  56.         if {[array size unknown_pending] == 0} {
  57.         unset unknown_pending
  58.         }
  59.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  60.     }
  61.     set unknown_pending($name) pending;
  62.     set ret [catch {auto_load $name} msg]
  63.     unset unknown_pending($name);
  64.     if {$ret != 0} {
  65.         return -code $ret "error while autoloading \"$name\": $msg"
  66.     }
  67.     if ![array size unknown_pending] {
  68.         unset unknown_pending
  69.     }
  70.     if $msg {
  71.         return [uplevel $args]
  72.     }
  73.     }
  74.     if {([info level] == 1) && ([info script] == "") && $tcl_interactive} {
  75.     if ![info exists auto_noexec] {
  76.         if [auto_execok $name] {
  77.         return [uplevel exec >&@stdout <@stdin $args]
  78.         }
  79.     }
  80.     if {$name == "!!"} {
  81.         return [uplevel {history redo}]
  82.     }
  83.     if [regexp {^!(.+)$} $name dummy event] {
  84.         return [uplevel [list history redo $event]]
  85.     }
  86.     if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  87.         return [uplevel [list history substitute $old $new]]
  88.     }
  89.     set cmds [info commands $name*]
  90.     if {[llength $cmds] == 1} {
  91.         return [uplevel [lreplace $args 0 0 $cmds]]
  92.     }
  93.     if {[llength $cmds] != 0} {
  94.         if {$name == ""} {
  95.         return -code error "empty command name \"\""
  96.         } else {
  97.         return -code error \
  98.             "ambiguous command name \"$name\": [lsort $cmds]"
  99.         }
  100.     }
  101.     }
  102.     return -code error "invalid command name \"$name\""
  103. }
  104.  
  105. # auto_load:
  106. # Checks a collection of library directories to see if a procedure
  107. # is defined in one of them.  If so, it sources the appropriate
  108. # library file to create the procedure.  Returns 1 if it successfully
  109. # loaded the procedure, 0 otherwise.
  110.  
  111. proc auto_load cmd {
  112.     global auto_index auto_oldpath auto_path env errorInfo errorCode
  113.  
  114.     if [info exists auto_index($cmd)] {
  115.     uplevel #0 $auto_index($cmd)
  116.     return 1
  117.     }
  118.     if [catch {set path $auto_path}] {
  119.     if [catch {set path $env(TCLLIBPATH)}] {
  120.         if [catch {set path [info library]}] {
  121.         return 0
  122.         }
  123.     }
  124.     }
  125.     if [info exists auto_oldpath] {
  126.     if {$auto_oldpath == $path} {
  127.         return 0
  128.     }
  129.     }
  130.     set auto_oldpath $path
  131.     catch {unset auto_index}
  132.     for {set i [expr [llength $path] - 1]} {$i >= 0} {incr i -1} {
  133.     set dir [lindex $path $i]
  134.     set f ""
  135.     if [catch {set f [open $dir/tclIndex]}] {
  136.         continue
  137.     }
  138.     set error [catch {
  139.         set id [gets $f]
  140.         if {$id == "# Tcl autoload index file, version 2.0"} {
  141.         eval [read $f]
  142.         } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
  143.         while {[gets $f line] >= 0} {
  144.             if {([string index $line 0] == "#")
  145.                 || ([llength $line] != 2)} {
  146.             continue
  147.             }
  148.             set name [lindex $line 0]
  149.             set auto_index($name) "source $dir/[lindex $line 1]"
  150.         }
  151.         } else {
  152.         error "$dir/tclIndex isn't a proper Tcl index file"
  153.         }
  154.     } msg]
  155.     if {$f != ""} {
  156.         close $f
  157.     }
  158.     if $error {
  159.         error $msg $errorInfo $errorCode
  160.     }
  161.     }
  162.     if [info exists auto_index($cmd)] {
  163.     uplevel #0 $auto_index($cmd)
  164.     if {[info commands $cmd] != ""} {
  165.         return 1
  166.     }
  167.     }
  168.     return 0
  169. }
  170.  
  171. # auto_execok:
  172. # Returns 1 if there's an executable in the current path for the
  173. # given name, 0 otherwise.  Builds an associative array auto_execs
  174. # that caches information about previous checks, for speed.
  175.  
  176. proc auto_execok name {
  177.     global auto_execs env
  178.  
  179.     if [info exists auto_execs($name)] {
  180.     return $auto_execs($name)
  181.     }
  182.     set auto_execs($name) 0
  183.     if {[string first / $name] >= 0} {
  184.     if {[file executable $name] && ![file isdirectory $name]} {
  185.         set auto_execs($name) 1
  186.     }
  187.     return $auto_execs($name)
  188.     }
  189.     foreach dir [split $env(PATH) :] {
  190.     if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
  191.         set auto_execs($name) 1
  192.         return 1
  193.     }
  194.     }
  195.     return 0
  196. }
  197.  
  198. # auto_reset:
  199. # Destroy all cached information for auto-loading and auto-execution,
  200. # so that the information gets recomputed the next time it's needed.
  201. # Also delete any procedures that are listed in the auto-load index
  202. # except those related to auto-loading.
  203.  
  204. proc auto_reset {} {
  205.     global auto_execs auto_index auto_oldpath
  206.     foreach p [info procs] {
  207.     if {[info exists auto_index($p)] && ($p != "unknown")
  208.         && ![string match auto_* $p]} {
  209.         rename $p {}
  210.     }
  211.     }
  212.     catch {unset auto_execs}
  213.     catch {unset auto_index}
  214.     catch {unset auto_oldpath}
  215. }
  216.  
  217. # auto_mkindex:
  218. # Regenerate a tclIndex file from Tcl source files.  Takes as argument
  219. # the name of the directory in which the tclIndex file is to be placed,
  220. # floowed by any number of glob patterns to use in that directory to
  221. # locate all of the relevant files.
  222.  
  223. proc auto_mkindex {dir args} {
  224.     global errorCode errorInfo
  225.     set oldDir [pwd]
  226.     cd $dir
  227.     set dir [pwd]
  228.     append index "# Tcl autoload index file, version 2.0\n"
  229.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  230.     append index "# and sourced to set up indexing information for one or\n"
  231.     append index "# more commands.  Typically each line is a command that\n"
  232.     append index "# sets an element in the auto_index array, where the\n"
  233.     append index "# element name is the name of a command and the value is\n"
  234.     append index "# a script that loads the command.\n\n"
  235.     foreach file [eval glob $args] {
  236.     set f ""
  237.     set error [catch {
  238.         set f [open $file]
  239.         while {[gets $f line] >= 0} {
  240.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  241.             append index "set [list auto_index($procName)]"
  242.             append index " \"source \$dir/$file\"\n"
  243.         }
  244.         }
  245.         close $f
  246.     } msg]
  247.     if $error {
  248.         set code $errorCode
  249.         set info $errorInfo
  250.         catch {close $f}
  251.         cd $oldDir
  252.         error $msg $info $code
  253.     }
  254.     }
  255.     set f [open tclIndex w]
  256.     puts $f $index nonewline
  257.     close $f
  258.     cd $oldDir
  259. }
  260.